Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/sptmbr16.lha/fin.lisp

Text File | 1992-12-21 | 69KB | 1,963 lines

;;;-*-Mode:LISP; Package:(PCL Lisp 1000); Base:10; Syntax:Common-lisp -*-
;;;
;;; *************************************************************************
;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation.
;;; All rights reserved.
;;;
;;; Use and copying of this software and preparation of derivative works
;;; based upon this software are permitted.  Any distribution of this
;;; software or derivative works must comply with all applicable United
;;; States export control laws.
;;;
;;; This software is made available AS IS, and Xerox Corporation makes no
;;; warranty about the software, its performance or its conformity to any
;;; specification.
;;;
;;; Any person obtaining a copy of this software is requested to send their
;;; name and post office or electronic mail address to:
;;;   CommonLoops Coordinator
;;;   Xerox PARC
;;;   3333 Coyote Hill Rd.
;;;   Palo Alto, CA 94304
;;; (or send Arpanet mail to [e-mail])
;;;
;;; Suggestions, comments and requests for improvements are also welcome.
;;; *************************************************************************
;;;

  ;;
;;;;;; FUNCALLABLE INSTANCES
  ;;

#|

Generic functions are instances with meta class funcallable-standard-class.
Instances with this meta class are called funcallable-instances (FINs for
short).  They behave something like lexical closures in that they have data
associated with them (which is used to store the slots) and are funcallable.
When a funcallable instance is funcalled, the function that is invoked is
called the funcallable-instance-function.  The funcallable-instance-function
of a funcallable instance can be changed.

This file implements low level code for manipulating funcallable instances.

It is possible to implement funcallable instances in pure Common Lisp.  A
simple implementation which uses lexical closures as the instances and a
hash table to record that the lexical closures are funcallable instances
is easy to write.  Unfortunately, this implementation adds significant
overhead:

   to generic-function-invocation (1 function call)
   to slot-access (1 function call or one hash table lookup)
   to class-of a generic-function (1 hash-table lookup)

In addition, it would prevent the funcallable instances from being garbage
collected.  In short, the pure Common Lisp implementation really isn't
practical.

Instead, PCL uses a specially tailored implementation for each Common Lisp and
makes no attempt to provide a purely portable implementation.  The specially
tailored implementations are based on the lexical closure's provided by that
implementation and are fairly short and easy to write.

Some of the implementation dependent code in this file was originally written
by someone in the employ of the vendor of that Common Lisp.  That code is
explicitly marked saying who wrote it.

|#

(in-package :pcl)

;;;
;;; The first part of the file contains the implementation dependent code to
;;; implement funcallable instances.  Each implementation must provide the
;;; following functions and macros:
;;;
;;;    ALLOCATE-FUNCALLABLE-INSTANCE-1 ()
;;;       should create and return a new funcallable instance.  The
;;;       funcallable-instance-data slots must be initialized to NIL.
;;;       This is called by allocate-funcallable-instance and by the
;;;       bootstrapping code.
;;;
;;;    FUNCALLABLE-INSTANCE-P (x)
;;;       the obvious predicate.  This should be an INLINE function.
;;;       it must be funcallable, but it would be nice if it compiled
;;;       open.
;;;
;;;    SET-FUNCALLABLE-INSTANCE-FUNCTION (fin new-value)
;;;       change the fin so that when it is funcalled, the new-value
;;;       function is called.  Note that it is legal for new-value
;;;       to be copied before it is installed in the fin, specifically
;;;       there is no accessor for a FIN's function so this function
;;;       does not have to preserve the actual new value.  The new-value
;;;       argument can be any funcallable thing, a closure, lambda
;;;       compiled code etc.  This function must coerce those values
;;;       if necessary.
;;;       NOTE: new-value is almost always a compiled closure.  This
;;;             is the important case to optimize.
;;;
;;;    FUNCALLABLE-INSTANCE-DATA-1 (fin data-name)
;;;       should return the value of the data named data-name in the fin.
;;;       data-name is one of the symbols in the list which is the value
;;;       of funcallable-instance-data.  Since data-name is almost always
;;;       a quoted symbol and funcallable-instance-data is a constant, it
;;;       is possible (and worthwhile) to optimize the computation of
;;;       data-name's offset in the data part of the fin.
;;;       This must be SETF'able.
;;;

(eval-when (compile load eval)
(defconstant funcallable-instance-data
             '(wrapper slots)
  "These are the 'data-slots' which funcallable instances have so that
   the meta-class funcallable-standard-class can store class, and static
   slots in them.")
)

(defmacro funcallable-instance-data-position (data)
  (if (and (consp data)
           (eq (car data) 'quote))
      (or (position (cadr data) funcallable-instance-data :test #'eq)
          (progn
            (warn "Unknown funcallable-instance data: ~S." (cadr data))
            `(error "Unknown funcallable-instance data: ~S." ',(cadr data))))
      `(position ,data funcallable-instance-data :test #'eq)))

(proclaim '(notinline called-fin-without-function))
(defun called-fin-without-function (&rest args)
  (declare (ignore args))
  (error "Attempt to funcall a funcallable-instance without first~%~
          setting its funcallable-instance-function."))


;;;
;;; In Lucid Lisp, compiled functions and compiled closures have the same
;;; representation.  They are called procedures.  A procedure is a basically
;;; just a constants vector, with one slot which points to the CODE.  This
;;; means that constants and closure variables are intermixed in the procedure
;;; vector.
;;;
;;; This code was largely written by [e-mail].  Problems with it should
;;; be referred to him.
;;;
#+Lucid
(progn

(defconstant procedure-is-funcallable-instance-bit-position 10)

(defconstant fin-trampoline-fun-index lucid::procedure-literals)

(defconstant fin-size (+ fin-trampoline-fun-index
             (length funcallable-instance-data)
             1))

;;;
;;; The inner closure of this function will have its code vector replaced
;;;  by a hand-coded fast jump to the function that is stored in the
;;;  captured-lexical variable.  In effect, that code is a hand-
;;;  optimized version of the code for this inner closure function.
;;;
(defun make-trampoline (function)
  (declare (optimize (speed 3) (safety 0)))
  #'(lambda (&rest args)
      (apply function args)))

(eval-when (eval)
  (compile 'make-trampoline)
  )


(defun binary-assemble (codes)
  (let* ((ncodes (length codes))
     (code-vec #-LCL3.0 (lucid::new-code ncodes)
           #+LCL3.0 (lucid::with-current-area
                lucid::*READONLY-NON-POINTER-AREA*
                  (lucid::new-code ncodes))))
    (declare (fixnum ncodes))
    (do ((l codes (cdr l))
     (i 0 (1+ i)))
    ((null l) nil)
      (declare (fixnum i))
      (setf (lucid::code-ref code-vec i) (car l)))
    code-vec))

;;;
;;; Egad! Binary patching!
;;; See comment following definition of MAKE-TRAMPOLINE -- this is just
;;;  the "hand-optimized" machine instructions to make it work.
;;;
(defvar *mattress-pad-code*
    (binary-assemble
        #+MC68000
        '(#x2A6D #x11 #x246D #x1 #x4EEA #x5)
        #+SPARC
        (ecase (lucid::procedure-length #'lucid::false)
          (5
           '(#xFA07 #x6012 #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0))
          (8
           `(#xFA07 #x601E #xDE07 #x7FFE #x81C3 #xFFFE #x100 #x0)))
        #+(and BSP (not LCL3.0 ))
        '(#xCD33 #x11 #xCDA3 #x1 #xC19A #x5 #xE889)
        #+(and BSP LCL3.0)
        '(#x7733 #x7153 #xC155 #x5 #xE885)
        #+I386
        '(#x87 #xD2 #x8B #x76 #xE #xFF #x66 #xFE)
        #+VAX
        '(#xD0 #xAC #x11 #x5C #xD0 #xAC #x1 #x57 #x17 #xA7 #x5)
        #+PA
        '(#x4891 #x3C #xE461 #x6530 #x48BF #x3FF9)
                #+MIPS
                '(#x8FD4 #x1E #x2785 #x2EEF #xA0 #x8 #x14 #xF000)
                #-(or MC68000 SPARC BSP I386 VAX PA MIPS)
        '(0 0 0 0)))


(lucid::defsubst funcallable-instance-p (x)
  (and (lucid::procedurep x)
       (lucid::logbitp& procedure-is-funcallable-instance-bit-position
                        (lucid::procedure-ref x lucid::procedure-flags))))

(lucid::defsubst set-funcallable-instance-p (x)
  (if (not (lucid::procedurep x))
      (error "Can't make a non-procedure a fin.")
      (setf (lucid::procedure-ref x lucid::procedure-flags)
        (logior (expt 2 procedure-is-funcallable-instance-bit-position)
            (the fixnum
             (lucid::procedure-ref x lucid::procedure-flags))))))


(defun allocate-funcallable-instance-1 ()
  #+Prime
  (declare (notinline lucid::new-procedure))    ;fixes a bug in Prime 1.0 in
                                                ;which new-procedure expands
                                                ;incorrectly
  (let ((new-fin (lucid::new-procedure fin-size))
    (fin-index fin-size))
    (declare (fixnum fin-index)
         (type lucid::procedure new-fin))
    (dotimes (i (length funcallable-instance-data))
      ;; Initialize the new funcallable-instance.  As part of our contract,
      ;; we have to make sure the initial value of all the funcallable
      ;; instance data slots is NIL.
      (decf fin-index)
      (setf (lucid::procedure-ref new-fin fin-index) nil))
    ;;
    ;; "Assemble" the initial function by installing a fast "trampoline" code;
    ;;
    (setf (lucid::procedure-ref new-fin lucid::procedure-code)
      *mattress-pad-code*)
    ;; Disable argcount checking in the "mattress-pad" code for
    ;;  ports that go through standardized trampolines
    #+PA (setf (sys:procedure-ref new-fin lucid::procedure-arg-count) -1)
    #+MIPS (progn
         (setf (sys:procedure-ref new-fin lucid::procedure-min-args) 0)
         (setf (sys:procedure-ref new-fin lucid::procedure-max-args)
           call-arguments-limit))
    ;; but start out with the function to be run as an error call.
    (setf (lucid::procedure-ref new-fin fin-trampoline-fun-index)
      #'called-fin-without-function)
    ;; Then mark it as a "fin"
    (set-funcallable-instance-p new-fin)
    new-fin))

(defun set-funcallable-instance-function (fin new-value)
  (unless (funcallable-instance-p fin)
    (error "~S is not a funcallable-instance" fin))
  (if (lucid::procedurep new-value)
      (progn
    (setf (lucid::procedure-ref fin fin-trampoline-fun-index) new-value)
    fin)
      (progn
    (unless (functionp new-value)
      (error "~S is not a function." new-value))
    ;; 'new-value' is an interpreted function.  Install a
    ;; trampoline to call the interpreted function.
    (set-funcallable-instance-function fin
                       (make-trampoline new-value)))))

(defmacro funcallable-instance-data-1 (instance data)
  `(lucid::procedure-ref
       ,instance
       (the fixnum
        (- (- fin-size 1)
           (the fixnum (funcallable-instance-data-position ,data))))))

);end of #+Lucid


;;;
;;; In Symbolics Common Lisp, a lexical closure is a pair of an environment
;;; and an ordinary compiled function.  The environment is represented as
;;; a CDR-coded list.  I know of no way to add a special bit to say that the
;;; closure is a FIN, so for now, closures are marked as FINS by storing a
;;; special marker in the last cell of the environment.
;;;
;;;  The new structure of a fin is:
;;;     (lex-env lex-fun *marker* fin-data0 fin-data1)
;;;  The value returned by allocate is a lexical-closure pointing to the start
;;;  of the fin list.  Benefits are: no longer ever have to copy environments,
;;;  fins can be much smaller (5 words instead of 18), old environments never
;;;  get destroyed (so running dcodes dont have the lex env change from under
;;;  them any longer).
;;;
;;;  Most of the fin operations speed up a little (by as much as 30% on a
;;;  3650), at least one nasty bug is fixed, and so far at least I've not
;;;  seen any problems at all with this code.   - mike thome ([e-mail])
;;;
#+(and Genera (not Genera-Release-8))
(progn

(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))

(defun allocate-funcallable-instance-1 ()
  (let* ((whole-fin (make-list (+ 3 (length funcallable-instance-data))))
     (new-fin (sys:%make-pointer-offset sys:dtp-lexical-closure
                        whole-fin
                        0)))
    ;;
    ;; note that we DO NOT turn the real lex-closure part of the fin into
    ;; a dotted pair, because (1) the machine doesn't care and (2) if we
    ;; did the garbage collector would reclaim everything after the lexical
    ;; function.
    ;;
    (setf (sys:%p-contents-offset new-fin 2) *funcallable-instance-marker*)
    (setf (si:lexical-closure-function new-fin)
      #'(lambda (ignore &rest ignore-them-too)
          (declare (ignore ignore ignore-them-too))
          (called-fin-without-function)))
    #+ignore
    (setf (si:lexical-closure-environment new-fin) nil)
    new-fin))

(scl:defsubst funcallable-instance-p (x)
  (declare (inline si:lexical-closure-p))
  (and (si:lexical-closure-p x)
       (= (sys:%p-cdr-code (sys:%make-pointer-offset sys:dtp-compiled-function x 1))
      sys:cdr-next)
       (eq (sys:%p-contents-offset x 2) *funcallable-instance-marker*)))

(defun set-funcallable-instance-function (fin new-value)
  (cond ((not (funcallable-instance-p fin))
         (error "~S is not a funcallable-instance" fin))
        ((not (or (functionp new-value)
          (and (consp new-value)
               (eq (car new-value) 'si:digested-lambda))))
         (error "~S is not a function." new-value))
        ((and (si:lexical-closure-p new-value)
          (compiled-function-p (si:lexical-closure-function new-value)))
     (let ((env (si:lexical-closure-environment new-value))
           (fn  (si:lexical-closure-function new-value)))
       ;; we only have to copy the pointers!!
       (setf (si:lexical-closure-environment fin) env
         (si:lexical-closure-function fin)    fn)
;       (dbg:set-env->fin env fin)
       ))
        (t
         (set-funcallable-instance-function fin
                                            (make-trampoline new-value)))))

(defun make-trampoline (function)
  (declare (optimize (speed 3) (safety 0)))
  #'(lambda (&rest args)
      #+Genera (declare (dbg:invisible-frame :pcl-internals))
      (apply function args)))

(defmacro funcallable-instance-data-1 (fin data)
  `(sys:%p-contents-offset ,fin
               (+ 3 (funcallable-instance-data-position ,data))))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(setf (sys:%p-contents-offset ,fin
                 (+ 3 (funcallable-instance-data-position ,data)))
     ,new-value))

;;;
;;; Make funcallable instances print out properly.
;;;
(defvar *print-lexical-closure* nil)

(defun pcl-print-lexical-closure (exp stream slashify-p &optional (depth 0))
  (declare (ignore depth))
  (declare (special *boot-state*))
  (if (or (eq *print-lexical-closure* exp)
      (neq *boot-state* 'complete)
      (eq (class-of exp) *the-class-t*))
      (let ((*print-lexical-closure* nil))
    (funcall (original-definition 'si:print-lexical-closure)
         exp stream slashify-p))
      (let ((*print-escape* slashify-p)
        (*print-lexical-closure* exp))
    (print-object exp stream))))

(unless (boundp '*boot-state*)
  (setq *boot-state* nil))

(redefine-function 'si:print-lexical-closure 'pcl-print-lexical-closure)

(defvar *function-name-level* 0)

(defun pcl-function-name (function &rest other-args)
  (if (and (eq *boot-state* 'complete)
       (funcallable-instance-p function)
       (generic-function-p function)
       (<= *function-name-level* 2))
      (let ((*function-name-level* (1+ *function-name-level*)))
    (generic-function-name function))
      (apply (original-definition 'si:function-name) function other-args)))

(redefine-function 'si:function-name 'pcl-function-name)

(defun pcl-arglist (function &rest other-args)
  (let ((defn nil))
    (cond ((and (funcallable-instance-p function)
        (generic-function-p function))
       (generic-function-pretty-arglist function))
      ((and (sys:validate-function-spec function)
        (sys:fdefinedp function)
        (setq defn (sys:fdefinition function))
        (funcallable-instance-p defn)
        (generic-function-p defn))
       (generic-function-pretty-arglist defn))
      (t (apply (original-definition 'zl:arglist) function other-args)))))

(redefine-function 'zl:arglist 'pcl-arglist)


;;;
;;; This code is adapted from frame-lexical-environment and frame-function.
;;;
#||
dbg:
(progn

(defvar *old-frame-function*)

(defvar *inside-new-frame-function* nil)

(defun new-frame-function (frame)
  (let* ((fn (funcall *old-frame-function* frame))
     (location (%pointer-plus frame #+imach (defstorage-size stack-frame) #-imach 0))
     (env? #+3600 (location-contents location)
           #+imach (%memory-read location :cycle-type %memory-scavenge)))
    (or (when (cl:consp env?)
      (let ((l2 (last2 env?)))
        (when (eq (car l2) '.this-is-a-dfun.)
          (cadr l2))))
    fn)))

(defun pcl::doctor-dfun-for-the-debugger (gf dfun)
  (when (sys:lexical-closure-p dfun)
    (let* ((env (si:lexical-closure-environment dfun))
       (l2 (last2 env)))
      (unless (eq (car l2) '.this-is-a-dfun.)
    (setf (si:lexical-closure-environment dfun)
          (nconc env (list '.this-is-a-dfun. gf))))))
  dfun)

(defun last2 (l)
  (labels ((scan (2ago tail)
         (if (null tail)
         2ago
         (if (cl:consp tail)
             (scan (cdr 2ago) (cdr tail))
             nil))))
    (and (cl:consp l)
     (cl:consp (cdr l))
     (scan l (cddr l)))))

(eval-when (load)
  (unless (boundp '*old-frame-function*)
    (setq *old-frame-function* #'frame-function)
    (setf (cl:symbol-function 'frame-function) 'new-frame-function)))

)
||#

);end of #+Genera



;;;
;;; In Genera 8.0, we use a real funcallable instance (from Genera CLOS) for this.
;;; This minimizes the subprimitive mucking around.
;;;
#+(and Genera Genera-Release-8)
(progn

(clos-internals::ensure-class
  'pcl-funcallable-instance
  :direct-superclasses '(clos-internals:funcallable-instance)
  :slots `((:name function
        :initform #'(lambda (ignore &rest ignore-them-too)
              (declare (ignore ignore ignore-them-too))
              (called-fin-without-function))
        :initfunction ,#'(lambda nil
                   #'(lambda (ignore &rest ignore-them-too)
                   (declare (ignore ignore ignore-them-too))
                   (called-fin-without-function))))
       ,@(mapcar #'(lambda (slot) `(:name ,slot)) funcallable-instance-data))
  :metaclass 'clos:funcallable-standard-class)

(defun pcl-funcallable-instance-trampoline (extra-arg &rest args)
  (apply (sys:%instance-ref (clos-internals::%dispatch-instance-from-extra-argument extra-arg)
                3)
     args))

(defun allocate-funcallable-instance-1 ()
  (let ((fin (clos:make-instance 'pcl-funcallable-instance)))
    (setf (clos-internals::%funcallable-instance-function fin)
      #'pcl-funcallable-instance-trampoline)
    (setf (clos-internals::%funcallable-instance-extra-argument fin)
      (sys:%make-pointer sys:dtp-instance
                 (clos-internals::%funcallable-instance-extra-argument fin)))
    (setf (clos:slot-value fin 'clos-internals::funcallable-instance) fin)
    fin))

(scl:defsubst funcallable-instance-p (x)
  (and (sys:funcallable-instance-p x)
       (eq (clos-internals::%funcallable-instance-function x)
       #'pcl-funcallable-instance-trampoline)))

(defun set-funcallable-instance-function (fin new-value)
  (setf (clos:slot-value fin 'function) new-value))

(defmacro funcallable-instance-data-1 (fin data)
  `(clos-internals:%funcallable-instance-ref
     ,fin (+ 4 (funcallable-instance-data-position ,data))))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(setf (clos-internals:%funcallable-instance-ref
       ,fin (+ 4 (funcallable-instance-data-position ,data)))
     ,new-value))

(clos:defmethod clos:print-object ((fin pcl-funcallable-instance) stream)
  (print-object fin stream))

(clos:defmethod clos-internals:debugging-information-function ((fin pcl-funcallable-instance))
  nil)

(clos:defmethod clos-internals:function-name-object ((fin pcl-funcallable-instance))
  (declare (special *boot-state*))
  (if (and (eq *boot-state* 'complete)
       (generic-function-p fin))
      (generic-function-name fin)
      fin))

(clos:defmethod clos-internals:arglist-object ((fin pcl-funcallable-instance))
  (declare (special *boot-state*))
  (if (and (eq *boot-state* 'complete)
       (generic-function-p fin))
      (generic-function-pretty-arglist fin)
      '(&rest args)))

);end of #+Genera



#+Cloe-Runtime
(progn

(defconstant funcallable-instance-closure-slots 5)
(defconstant funcallable-instance-closure-size
         (+ funcallable-instance-closure-slots (length funcallable-instance-data) 1))

#-CLOE-Release-2 (progn

(defun allocate-funcallable-instance-1 ()
  (let ((data (system::make-funcallable-structure 'funcallable-instance
                          funcallable-instance-closure-size)))
    (setf (system::%trampoline-ref data funcallable-instance-closure-slots)
      'funcallable-instance)
    (set-funcallable-instance-function
      data
      #'(lambda (&rest ignore-them-too)
      (declare (ignore ignore-them-too))
      (called-fin-without-function)))
    data))

(proclaim '(inline funcallable-instance-p))
(defun funcallable-instance-p (x)
  (and (typep x 'system::trampoline)
       (= (system::%trampoline-data-length x) funcallable-instance-closure-size)
       (eq (system::%trampoline-ref x funcallable-instance-closure-slots)
       'funcallable-instance)))

(defun set-funcallable-instance-function (fin new-value)
  (when (not (funcallable-instance-p fin))
    (error "~S is not a funcallable-instance" fin))
  (etypecase new-value
    (system::trampoline
      (let ((length (system::%trampoline-data-length new-value)))
    (cond ((> length funcallable-instance-closure-slots)
           (set-funcallable-instance-function
         fin
         #'(lambda (&rest args)
             (declare (sys:downward-rest-argument))
             (apply new-value args))))
          (t
           (setf (system::%trampoline-function fin)
             (system::%trampoline-function new-value))
           (dotimes (i length)
         (setf (system::%trampoline-ref fin i)
               (system::%trampoline-ref new-value i)))))))
    (compiled-function
      (setf (system::%trampoline-function fin) new-value))
    (function
      (set-funcallable-instance-function
    fin
    #'(lambda (&rest args)
        (declare (sys:downward-rest-argument))
        (apply new-value args))))))

(defmacro funcallable-instance-data-1 (fin data)
  `(system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
                    1 (funcallable-instance-data-position ,data))))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(setf (system::%trampoline-ref ,fin (+ funcallable-instance-closure-slots
                      1 (funcallable-instance-data-position ,data)))
     ,new-value))

)

#+CLOE-Release-2 (progn

(defun allocate-funcallable-instance-1 ()
  (let ((data (si::cons-closure funcallable-instance-closure-size)))
    (setf (si::closure-ref data funcallable-instance-closure-slots) 'funcallable-instance)
    (set-funcallable-instance-function
      data
      #'(lambda (&rest ignore-them-too)
      (declare (ignore ignore-them-too))
      (error "Called a FIN without first setting its function.")))
    data))

(proclaim '(inline funcallable-instance-p))
(defun funcallable-instance-p (x)
  (and (si::closurep x)
       (= (si::closure-length x) funcallable-instance-closure-size)
       (eq (si::closure-ref x funcallable-instance-closure-slots) 'funcallable-instance)))

(defun set-funcallable-instance-function (fin new-value)
  (when (not (funcallable-instance-p fin))
    (error "~S is not a funcallable-instance" fin))
  (etypecase new-value
    (si::closure
      (let ((length (si::closure-length new-value)))
    (cond ((> length funcallable-instance-closure-slots)
           (set-funcallable-instance-function
         fin
         #'(lambda (&rest args)
             (declare (sys:downward-rest-argument))
             (apply new-value args))))
          (t
           (setf (si::closure-function fin) (si::closure-function new-value))
           (dotimes (i length)
         (si::object-set fin (+ i 3) (si::object-ref new-value (+ i 3))))))))
    (compiled-function
      (setf (si::closure-function fin) new-value))
    (function
      (set-funcallable-instance-function
    fin
    #'(lambda (&rest args)
        (declare (sys:downward-rest-argument))
        (apply new-value args))))))

(defmacro funcallable-instance-data-1 (fin data)
  `(si::closure-ref ,fin (+ funcallable-instance-closure-slots
                1 (funcallable-instance-data-position ,data))))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(setf (si::closure-ref ,fin (+ funcallable-instance-closure-slots
                  1 (funcallable-instance-data-position ,data)))
     ,new-value))

)

)


;;;
;;;
;;; In Xerox Common Lisp, a lexical closure is a pair of an environment and
;;; CCODEP.  The environment is represented as a block.  There is space in
;;; the top 8 bits of the pointers to the CCODE and the environment to use
;;; to mark the closure as being a FIN.
;;;
;;; To help the debugger figure out when it has found a FIN on the stack, we
;;; reserve the last element of the closure environment to use to point back
;;; to the actual fin.
;;;
;;; Note that there is code in xerox-low which lets us access the fields of
;;; compiled-closures and which defines the closure-overlay record.  That
;;; code is there because there are some clients of it in that file.
;;;
#+Xerox
(progn

;; Don't be fooled.  We actually allocate one bigger than this to have a place
;; to store the backpointer to the fin.  -smL
(defconstant funcallable-instance-closure-size 15)

;; This is only used in the file PCL-ENV.
(defvar *fin-env-type*
  (type-of (il:\\allocblock (1+ funcallable-instance-closure-size) t)))

;; Well, Gregor may be too proud to hack xpointers, but bvm and I aren't. -smL

(defstruct fin-env-pointer
  (pointer nil :type il:fullxpointer))

(defun fin-env-fin (fin-env)
  (fin-env-pointer-pointer
   (il:\\getbaseptr fin-env (* funcallable-instance-closure-size 2))))

(defun |set fin-env-fin| (fin-env new-value)
  (il:\\rplptr fin-env (* funcallable-instance-closure-size 2)
           (make-fin-env-pointer :pointer new-value))
  new-value)

(defsetf fin-env-fin |set fin-env-fin|)

;; The finalization function that will clean up the backpointer from the
;; fin-env to the fin.  This needs to be careful to not cons at all.  This
;; depends on there being no other finalization function on compiled-closures,
;; since there is only one finalization function per datatype.  Too bad.  -smL
(defun finalize-fin (fin)
  ;; This could use the fn funcallable-instance-p, but if we get here we know
  ;; that this is a closure, so we can skip that test.
  (when (il:fetch (closure-overlay funcallable-instance-p) il:of fin)
    (let ((env (il:fetch (il:compiled-closure il:environment) il:of fin)))
      (when env
    (setq env
          (il:\\getbaseptr env (* funcallable-instance-closure-size 2)))
    (when (il:typep env 'fin-env-pointer)
      (setf (fin-env-pointer-pointer env) nil)))))
  nil)                    ;Return NIL so GC can proceed

(eval-when (load)
  ;; Install the above finalization function.
  (when (fboundp 'finalize-fin)
    (il:\\set.finalization.function 'il:compiled-closure 'finalize-fin)))

(defun allocate-funcallable-instance-1 ()
  (let* ((env (il:\\allocblock (1+ funcallable-instance-closure-size) t))
         (fin (il:make-compiled-closure nil env)))
    (setf (fin-env-fin env) fin)
    (il:replace (closure-overlay funcallable-instance-p) il:of fin il:with 't)
    (set-funcallable-instance-function fin
      #'(lambda (&rest ignore)
          (declare (ignore ignore))
      (called-fin-without-function)))
    fin))

(xcl:definline funcallable-instance-p (x)
  (and (typep x 'il:compiled-closure)
       (il:fetch (closure-overlay funcallable-instance-p) il:of x)))

(defun set-funcallable-instance-function (fin new)
  (cond ((not (funcallable-instance-p fin))
         (error "~S is not a funcallable-instance" fin))
        ((not (functionp new))
         (error "~S is not a function." new))
        ((typep new 'il:compiled-closure)
         (let* ((fin-env
                  (il:fetch (il:compiled-closure il:environment) il:of fin))
                (new-env
                  (il:fetch (il:compiled-closure il:environment) il:of new))
                (new-env-size (if new-env (il:\\#blockdatacells new-env) 0))
                (fin-env-size (- funcallable-instance-closure-size
                                 (length funcallable-instance-data))))
           (cond ((and new-env
               (<= new-env-size fin-env-size))
          (dotimes (i fin-env-size)
            (il:\\rplptr fin-env
                 (* i 2)
                 (if (< i new-env-size)
                     (il:\\getbaseptr new-env (* i 2))
                     nil)))
          (setf (compiled-closure-fnheader fin)
            (compiled-closure-fnheader new)))
                 (t
                  (set-funcallable-instance-function
                    fin
                    (make-trampoline new))))))
        (t
         (set-funcallable-instance-function fin
                                            (make-trampoline new)))))

(defun make-trampoline (function)
  #'(lambda (&rest args)
      (apply function args)))


(defmacro funcallable-instance-data-1 (fin data)
  `(il:\\getbaseptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
            (* (- funcallable-instance-closure-size
              (funcallable-instance-data-position ,data)
              1)            ;Reserve last element to
                        ;point back to actual FIN!
               2)))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(il:\\rplptr (il:fetch (il:compiled-closure il:environment) il:of ,fin)
        (* (- funcallable-instance-closure-size
              (funcallable-instance-data-position ,data)
              1)
           2)
        ,new-value))

);end of #+Xerox


;;;
;;; In Franz Common Lisp ExCL
;;; This code was originally written by:
;;;   [e-mail]
;;; and hacked by:
;;;   [e-mail]

#+ExCL
(progn

(defconstant funcallable-instance-flag-bit #x1)

(defun funcallable-instance-p (x)
   (and (excl::function-object-p x)
        (eq funcallable-instance-flag-bit
            (logand (excl::fn_flags x)
                    funcallable-instance-flag-bit))))

(defun make-trampoline (function)
  #'(lambda (&rest args)
      (apply function args)))

;; We initialize a fin's procedure function to this because
;; someone might try to funcall it before it has been set up.
(defun init-fin-fun (&rest ignore)
  (declare (ignore ignore))
  (called-fin-without-function))


(eval-when (eval)
  (compile 'make-trampoline)
  (compile 'init-fin-fun))


;; new style
#+(and gsgc (not sun4) (not cray) (not mips))
(progn
;; set-funcallable-instance-function must work by overwriting the fin itself
;; because the fin must maintain EQ identity.
;; Because the gsgc time needs several of the fields in the function object
;; at gc time in order to walk the stack frame, it is important never to bash
;; a function object that is active in a frame on the stack.  Besides, changing
;; the functions closure vector, not to mention overwriting its constant
;; vector, would scramble it's execution when that stack frame continues.
;; Therefore we represent a fin as a funny compiled-function object.
;; The code vector of this object has some hand-coded instructions which
;; do a very fast jump into the real fin handler function.  The function
;; which is the fin object *never* creates a frame on the stack.


(defun allocate-funcallable-instance-1 ()
  (let ((fin (compiler::.primcall 'sys::new-function))
    (init #'init-fin-fun)
    (mattress-fun #'funcallable-instance-mattress-pad))
    (setf (excl::fn_symdef fin) 'anonymous-fin)
    (setf (excl::fn_constant fin) init)
    (setf (excl::fn_code fin)        ; this must be before fn_start
      (excl::fn_code mattress-fun))
    (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
    (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
                       funcallable-instance-flag-bit))
    (setf (excl::fn_closure fin)
      (make-array (length funcallable-instance-data)))

    fin))

;; This function gets its code vector modified with a hand-coded fast jump
;; to the function that is stored in place of its constant vector.
;; This function is never linked in and never appears on the stack.

(defun funcallable-instance-mattress-pad ()
  (declare (optimize (speed 3) (safety 0)))
  'nil)

(eval-when (eval)
  (compile 'funcallable-instance-mattress-pad))


#+(and excl (target-class s))
(eval-when (load eval)
  (let ((codevec (excl::fn_code
          (symbol-function 'funcallable-instance-mattress-pad))))
    ;; The entire code vector wants to be:
    ;;   move.l  7(a2),a2     ;#x246a0007
    ;;   jmp     1(a2)        ;#x4eea0001
    (setf (aref codevec 0) #x246a
      (aref codevec 1) #x0007
      (aref codevec 2) #x4eea
      (aref codevec 3) #x0001))
)

#+(and excl (target-class a))
(eval-when (load eval)
  (let ((codevec (excl::fn_code
          (symbol-function 'funcallable-instance-mattress-pad))))
    ;; The entire code vector wants to be:
    ;;   l       r5,15(r5)    ;#x5850500f
    ;;   l       r15,11(r5)   ;#x58f0500b
    ;;   br      r15          ;#x07ff
    (setf (aref codevec 0) #x5850
      (aref codevec 1) #x500f
      (aref codevec 2) #x58f0
      (aref codevec 3) #x500b
      (aref codevec 4) #x07ff
      (aref codevec 5) #x0000))
  )

#+(and excl (target-class i))
(eval-when (load eval)
  (let ((codevec (excl::fn_code
          (symbol-function 'funcallable-instance-mattress-pad))))
    ;; The entire code vector wants to be:
    ;;   movl  7(edx),edx     ;#x07528b
    ;;   jmp   *3(edx)        ;#x0362ff
    (setf (aref codevec 0) #x8b
      (aref codevec 1) #x52
      (aref codevec 2) #x07
      (aref codevec 3) #xff
      (aref codevec 4) #x62
      (aref codevec 5) #x03))
)

(defun funcallable-instance-data-1 (instance data)
  (let ((constant (excl::fn_closure instance)))
    (svref constant (funcallable-instance-data-position data))))

(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)

(defun set-funcallable-instance-data-1 (instance data new-value)
  (let ((constant (excl::fn_closure instance)))
    (setf (svref constant (funcallable-instance-data-position data))
          new-value)))

(defun set-funcallable-instance-function (fin new-function)
  (unless (funcallable-instance-p fin)
    (error "~S is not a funcallable-instance" fin))
  (unless (functionp new-function)
    (error "~S is not a function." new-function))
  (setf (excl::fn_constant fin)
    (if (excl::function-object-p new-function)
        new-function
        ;; The new-function is an interpreted function.
        ;; Install a trampoline to call the interpreted function.
        (make-trampoline new-function))))


)  ;; end sun3


#+(and gsgc (or sun4 mips))
(progn

(eval-when (compile load eval)
  (defconstant funcallable-instance-constant-count 15)
  )

(defun allocate-funcallable-instance-1 ()
  (let ((new-fin (compiler::.primcall
           'sys::new-function
           funcallable-instance-constant-count)))
    ;; Have to set the procedure function to something for two reasons.
    ;;   1. someone might try to funcall it.
    ;;   2. the flag bit that says the procedure is a funcallable
    ;;      instance is set by set-funcallable-instance-function.
    (set-funcallable-instance-function new-fin #'init-fin-fun)
    new-fin))

(defun set-funcallable-instance-function (fin new-value)
  ;; we actually only check for a function object since
  ;; this is called before the funcallable instance flag is set
  (unless (excl::function-object-p fin)
    (error "~S is not a funcallable-instance" fin))

  (cond ((not (functionp new-value))
         (error "~S is not a function." new-value))
        ((not (excl::function-object-p new-value))
         ;; new-value is an interpreted function.  Install a
         ;; trampoline to call the interpreted function.
         (set-funcallable-instance-function fin (make-trampoline new-value)))
    ((> (+ (excl::function-constant-count new-value)
           (length funcallable-instance-data))
        funcallable-instance-constant-count)
     ; can't fit, must trampoline
     (set-funcallable-instance-function fin (make-trampoline new-value)))
        (t
         ;; tack the instance variables at the end of the constant vector

         (setf (excl::fn_code fin)    ; this must be before fn_start
           (excl::fn_code new-value))
         (setf (excl::fn_start fin) (excl::fn_start new-value))

         (setf (excl::fn_closure fin) (excl::fn_closure new-value))
     ; only replace the symdef slot if the new value is an
     ; interned symbol or some other object (like a function spec)
     (let ((newsym (excl::fn_symdef new-value)))
       (excl:if* (and newsym (or (not (symbolp newsym))
                (symbol-package newsym)))
          then (setf (excl::fn_symdef fin) newsym)))
         (setf (excl::fn_formals fin) (excl::fn_formals new-value))
         (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
     (setf (excl::fn_locals fin) (excl::fn_locals new-value))
         (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
                                            funcallable-instance-flag-bit))

     ;; on a sun4 we copy over the constants
     (dotimes (i (excl::function-constant-count new-value))
       (setf (excl::function-constant fin i)
         (excl::function-constant new-value i)))
     ;(format t "all done copy from ~s to ~s" new-value fin)
     )))

(defmacro funcallable-instance-data-1 (instance data)
  `(excl::function-constant ,instance
               (- funcallable-instance-constant-count
                  (funcallable-instance-data-position ,data)
                  1)))

) ;; end sun4 or mips

#+(and gsgc cray)
(progn

;; The cray is like the sun4 in that the constant vector is included in the
;; function object itself.  But a mattress pad must be used anyway, because
;; the function start address is copied in the symbol object, and cannot be
;; updated when the fin is changed.
;; We place the funcallable-instance-function into the first constant slot,
;; and leave enough constant slots after that for the instance data.

(eval-when (compile load eval)
  (defconstant fin-fun-slot 0)
  (defconstant fin-instance-data-slot 1)
  )


;; We initialize a fin's procedure function to this because
;; someone might try to funcall it before it has been set up.
(defun init-fin-fun (&rest ignore)
  (declare (ignore ignore))
  (called-fin-without-function))

(defun allocate-funcallable-instance-1 ()
  (let ((fin (compiler::.primcall 'sys::new-function
            (1+ (length funcallable-instance-data))
            "funcallable-instance"))
    (init #'init-fin-fun)
    (mattress-fun #'funcallable-instance-mattress-pad))
    (setf (excl::fn_symdef fin) 'anonymous-fin)
    (setf (excl::function-constant fin fin-fun-slot) init)
    (setf (excl::fn_code fin)        ; this must be before fn_start
      (excl::fn_code mattress-fun))
    (setf (excl::fn_start fin) (excl::fn_start mattress-fun))
    (setf (excl::fn_flags fin) (logior (excl::fn_flags init)
                       funcallable-instance-flag-bit))

    fin))

;; This function gets its code vector modified with a hand-coded fast jump
;; to the function that is stored in place of its constant vector.
;; This function is never linked in and never appears on the stack.

(defun funcallable-instance-mattress-pad ()
  (declare (optimize (speed 3) (safety 0)))
  'nil)

(eval-when (eval)
  (compile 'funcallable-instance-mattress-pad)
  (compile 'init-fin-fun))

(eval-when (load eval)
  (let ((codevec (excl::fn_code
          (symbol-function 'funcallable-instance-mattress-pad))))
    ;; The entire code vector wants to be:
    ;;   a1  b77
    ;;   a2  12,a1
    ;;   a1 1,a2
    ;;   b77 a2
    ;;   b76 a1
    ;;   j   b76
    (setf (aref codevec 0) #o024177
      (aref codevec 1) #o101200 (aref codevec 2) 12
      (aref codevec 3) #o102100 (aref codevec 4) 1
      (aref codevec 5) #o025277
      (aref codevec 6) #o025176
      (aref codevec 7) #o005076
      ))
)

(defmacro funcallable-instance-data-1 (instance data)
  `(excl::function-constant ,instance
                (+ (funcallable-instance-data-position ,data)
                   fin-instance-dtat-slot)))


(defun set-funcallable-instance-function (fin new-function)
  (unless (funcallable-instance-p fin)
    (error "~S is not a funcallable-instance" fin))
  (unless (functionp new-function)
    (error "~S is not a function." new-function))
  (setf (excl::function-constant fin fin-fun-slot)
    (if (excl::function-object-p new-function)
    new-function
    ;; The new-function is an interpreted function.
    ;; Install a trampoline to call the interpreted function.
    (make-trampoline new-function))))

) ;; end cray

#-gsgc
(progn

(defun allocate-funcallable-instance-1 ()
  (let ((new-fin (compiler::.primcall 'sys::new-function)))
    ;; Have to set the procedure function to something for two reasons.
    ;;   1. someone might try to funcall it.
    ;;   2. the flag bit that says the procedure is a funcallable
    ;;      instance is set by set-funcallable-instance-function.
    (set-funcallable-instance-function new-fin #'init-fin-fn)
    new-fin))

(defun set-funcallable-instance-function (fin new-value)
  ;; we actually only check for a function object since
  ;; this is called before the funcallable instance flag is set
  (unless (excl::function-object-p fin)
    (error "~S is not a funcallable-instance" fin))
  (cond ((not (functionp new-value))
         (error "~S is not a function." new-value))
        ((not (excl::function-object-p new-value))
         ;; new-value is an interpreted function.  Install a
         ;; trampoline to call the interpreted function.
         (set-funcallable-instance-function fin (make-trampoline new-value)))
        (t
         ;; tack the instance variables at the end of the constant vector
         (setf (excl::fn_start fin) (excl::fn_start new-value))
         (setf (excl::fn_constant fin) (add-instance-vars
                                        (excl::fn_constant new-value)
                                        (excl::fn_constant fin)))
         (setf (excl::fn_closure fin) (excl::fn_closure new-value))
     ;; In versions prior to 2.0. comment the next line and any other
     ;; references to fn_symdef or fn_locals.
     (setf (excl::fn_symdef fin) (excl::fn_symdef new-value))
         (setf (excl::fn_code fin) (excl::fn_code new-value))
         (setf (excl::fn_formals fin) (excl::fn_formals new-value))
         (setf (excl::fn_cframe-size fin) (excl::fn_cframe-size new-value))
     (setf (excl::fn_locals fin) (excl::fn_locals new-value))
         (setf (excl::fn_flags fin) (logior (excl::fn_flags new-value)
                                            funcallable-instance-flag-bit)))))

(defun add-instance-vars (cvec old-cvec)
  ;; create a constant vector containing everything in the given constant
  ;; vector plus space for the instance variables
  (let* ((nconstants (cond (cvec (length cvec)) (t 0)))
         (ndata (length funcallable-instance-data))
         (old-cvec-length (if old-cvec (length old-cvec) 0))
         (new-cvec nil))
    (cond ((<= (+ nconstants ndata)  old-cvec-length)
           (setq new-cvec old-cvec))
          (t
           (setq new-cvec (make-array (+ nconstants ndata)))
           (when old-cvec
             (dotimes (i ndata)
               (setf (svref new-cvec (- (+ nconstants ndata) i 1))
                     (svref old-cvec (- old-cvec-length i 1)))))))

    (dotimes (i nconstants) (setf (svref new-cvec i) (svref cvec i)))

    new-cvec))

(defun funcallable-instance-data-1 (instance data)
  (let ((constant (excl::fn_constant instance)))
    (svref constant (- (length constant)
                       (1+ (funcallable-instance-data-position data))))))

(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)

(defun set-funcallable-instance-data-1 (instance data new-value)
  (let ((constant (excl::fn_constant instance)))
    (setf (svref constant (- (length constant)
                             (1+ (funcallable-instance-data-position data))))
          new-value)))

);end #-gsgc

);end of #+ExCL


;;;
;;; In Vaxlisp
;;; This code was originally written by:
;;;    [e-mail]
;;;
#+(and dec vax common)
(progn

;;; The following works only in Version 2 of VAXLISP, and will have to
;;; be replaced for later versions.

(defun allocate-funcallable-instance-1 ()
  (list 'system::%compiled-closure%
        ()
        #'(lambda (&rest args)
            (declare (ignore args))
        (called-fin-without-function))
        (make-array (length funcallable-instance-data))))

(proclaim '(inline funcallable-instance-p))
(defun funcallable-instance-p (x)
  (and (consp x)
       (eq (car x) 'system::%compiled-closure%)
       (not (null (cdddr x)))))

(defun set-funcallable-instance-function (fin func)
  (cond ((not (funcallable-instance-p fin))
         (error "~S is not a funcallable-instance" fin))
        ((not (functionp func))
         (error "~S is not a function" func))
        ((and (consp func) (eq (car func) 'system::%compiled-closure%))
         (setf (cadr fin) (cadr func)
               (caddr fin) (caddr func)))
        (t (set-funcallable-instance-function fin
                                              (make-trampoline func)))))

(defun make-trampoline (function)
  #'(lambda (&rest args)
      (apply function args)))

(eval-when (eval) (compile 'make-trampoline))

(defmacro funcallable-instance-data-1 (instance data)
  `(svref (cadddr ,instance)
          (funcallable-instance-data-position ,data)))

);end of Vaxlisp (and dec vax common)


;;;; Implementation of funcallable instances for CMU Common Lisp:
;;;
;;;    We represent a FIN like a closure, but the header has a distinct type
;;; tag.  The FIN data slots are stored at the end of a fixed-length closure
;;; (at FIN-DATA-OFFSET.)  When the function is set to a closure that has no
;;; more than FIN-DATA-OFFSET slots, we can just replace the slots in the FIN
;;; with the closure slots.  If the closure has too many slots, we must
;;; indirect through a trampoline with a rest arg.  For non-closures, we just
;;; set the function slot.
;;;
;;;    We can get away with this efficient and relatively simple scheme because
;;; the compiler currently currently only references closure slots during the
;;; initial call and on entry into the function.  So we don't have to worry
;;; about bad things happening when the FIN is clobbered (the problem JonL
;;; flames about somewhere...)
;;;
;;;    We also stick in a slot for the function name at the end, but before the
;;; data slots.

#+CMU
(import 'kernel:funcallable-instance-p)

#+CMU
(progn

(eval-when (compile load eval)
  ;;; The offset of the function's name & the max number of real closure slots.
  ;;;
  (defconstant fin-name-slot 14)

  ;;; The offset of the data slots.
  ;;;
  (defconstant fin-data-offset 15))


;;; ALLOCATE-FUNCALLABLE-INSTANCE-1  --  Interface
;;;
;;;    Allocate a funcallable instance, setting the function to an error
;;; function and initializing the data slots to NIL.
;;;
(defun allocate-funcallable-instance-1 ()
  (let* ((len (+ (length funcallable-instance-data) fin-data-offset))
         (res (kernel:%make-funcallable-instance
               len
               #'called-fin-without-function)))
    (dotimes (i (length funcallable-instance-data))
      (kernel:%set-funcallable-instance-info res (+ i fin-data-offset) nil))
    (kernel:%set-funcallable-instance-info res fin-name-slot nil)
    res))


;;; FUNCALLABLE-INSTANCE-P  --  Interface
;;;
;;;    Return true if X is a funcallable instance.  This is an interpreter
;;; stub; the compiler directly implements this function.
;;;
(defun funcallable-instance-p (x) (funcallable-instance-p x))


;;; SET-FUNCALLABLE-INSTANCE-FUNCTION  --  Interface
;;;
;;;    Set the function that is called when FIN is called.
;;;
(defun set-funcallable-instance-function (fin new-value)
  (declare (type function new-value))
  (assert (funcallable-instance-p fin))
  (ecase (kernel:get-type new-value)
    (#.vm:closure-header-type
     (let ((len (- (kernel:get-closure-length new-value)
                   (1- vm:closure-info-offset))))
       (cond ((> len fin-name-slot)
              (set-funcallable-instance-function
               fin
               #'(lambda (&rest args)
                   (apply new-value args))))
             (t
              (dotimes (i fin-data-offset)
                (kernel:%set-funcallable-instance-info
                 fin i
                 (if (>= i len)
                     nil
                     (kernel:%closure-index-ref new-value i))))
              (kernel:%set-funcallable-instance-function
               fin
               (kernel:%closure-function new-value))))))
    (#.vm:function-header-type
     (kernel:%set-funcallable-instance-function fin new-value)))
  new-value)


;;; FUNCALLABLE-INSTANCE-NAME, SET-FUNCALLABLE-INSTANCE-NAME  --  Interface
;;;
;;;    Read or set the name slot in a funcallable instance.
;;;
(defun funcallable-instance-name (fin)
  (kernel:%closure-index-ref fin fin-name-slot))
;;;
(defun set-funcallable-instance-name (fin new-value)
  (kernel:%set-funcallable-instance-info fin fin-name-slot new-value)
  new-value)
;;;
(defsetf funcallable-instance-name set-funcallable-instance-name)


;;; FUNCALLABLE-INSTANCE-DATA-1  --  Interface
;;;
;;;    If the slot is constant, use CLOSURE-REF with the appropriate offset,
;;; otherwise do a run-time lookup of the slot offset.
;;;
(defmacro funcallable-instance-data-1 (fin slot)
  (if (constantp slot)
      `(sys:%primitive c:closure-ref ,fin
                       ,(+ (or (position (eval slot) funcallable-instance-data)
                               (error "Unknown slot: ~S." (eval slot)))
                           fin-data-offset))
      (ext:once-only ((n-slot slot))
        `(kernel:%closure-index-ref
          ,fin
          (+ (or (position ,n-slot funcallable-instance-data)
                 (error "Unknown slot: ~S." ,n-slot))
             fin-data-offset)))))
;;;
(defmacro %set-funcallable-instance-data-1 (fin slot new-value)
  (ext:once-only ((n-fin fin)
                  (n-slot slot)
                  (n-val new-value))
    `(progn
       (kernel:%set-funcallable-instance-info
        ,n-fin
    ,(if (constantp slot)
         (+ (or (position (eval slot) funcallable-instance-data)
            (error "Unknown slot: ~S." (eval slot)))
        fin-data-offset)
         `(+ (or (position ,n-slot funcallable-instance-data)
             (error "Unknown slot: ~S." ,n-slot))
         fin-data-offset))
        ,n-val)
       ,n-val)))
;;;
(defsetf funcallable-instance-data-1 %set-funcallable-instance-data-1)

); End of #+cmu progn


;;;
;;; Kyoto Common Lisp (KCL)
;;;
;;; In KCL, compiled functions and compiled closures are defined as c structs.
;;; This means that in order to access their fields, we have to use C code!
;;; The C code we call and the lisp interface to it is in the file kcl-low.
;;; The lisp interface to this code implements accessors to compiled closures
;;; and compiled functions of about the same level of abstraction as that
;;; which is used by the other implementation dependent versions of FINs in
;;; this file.
;;;

#+(and KCL (not IBCL))
(progn

(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))

(defconstant funcallable-instance-closure-size 15)

(defconstant funcallable-instance-closure-size1
  (1- funcallable-instance-closure-size))

(defconstant funcallable-instance-available-size
  (- funcallable-instance-closure-size1
     (length funcallable-instance-data)))

(defmacro funcallable-instance-marker (x)
  `(car (cclosure-env-nthcdr funcallable-instance-closure-size1 ,x)))

(defun allocate-funcallable-instance-1 ()
  (let ((fin (allocate-funcallable-instance-2))
        (env (make-list funcallable-instance-closure-size :initial-element nil)))
    (setf (%cclosure-env fin) env)
    #+:turbo-closure (si:turbo-closure fin)
    (setf (funcallable-instance-marker fin) *funcallable-instance-marker*)
    fin))

(defun allocate-funcallable-instance-2 ()
  (let ((what-a-dumb-closure-variable ()))
    #'(lambda (&rest args)
        (declare (ignore args))
        (called-fin-without-function)
        (setq what-a-dumb-closure-variable
              (dummy-function what-a-dumb-closure-variable)))))

(defun funcallable-instance-p (x)
  (eq *funcallable-instance-marker* (funcallable-instance-marker x)))

(si:define-compiler-macro funcallable-instance-p (x)
  `(eq *funcallable-instance-marker* (funcallable-instance-marker ,x)))

(defun set-funcallable-instance-function (fin new-value)
  (cond ((not (funcallable-instance-p fin))
         (error "~S is not a funcallable-instance" fin))
        ((not (functionp new-value))
         (error "~S is not a function." new-value))
        ((and (cclosurep new-value)
              (<= (length (%cclosure-env new-value))
                  funcallable-instance-available-size))
         (%set-cclosure fin new-value funcallable-instance-available-size))
        (t
         (set-funcallable-instance-function
           fin (make-trampoline new-value))))
  fin)

(defmacro funcallable-instance-data-1 (fin data &environment env)
  ;; The compiler won't expand macros before deciding on optimizations,
  ;; so we must do it here.
  (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
                                env))
         (index-form (if (constantp pos-form)
                         (- funcallable-instance-closure-size
                            (eval pos-form)
                            2)
                         `(- funcallable-instance-closure-size
                             (funcallable-instance-data-position ,data)
                             2))))
    `(car (%cclosure-env-nthcdr ,index-form ,fin))))


#+turbo-closure (clines "#define TURBO_CLOSURE")

(clines "
static make_trampoline_internal();
static make_turbo_trampoline_internal();

static object
make_trampoline(function)
     object function;
{
  vs_push(MMcons(function,Cnil));
#ifdef TURBO_CLOSURE
  if(type_of(function)==t_cclosure)
    {if(function->cc.cc_turbo==NULL)turbo_closure(function);
     vs_head=make_cclosure(make_turbo_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
     return vs_pop;}
#endif
  vs_head=make_cclosure(make_trampoline_internal,Cnil,vs_head,Cnil,NULL,0);
  return vs_pop;
}

static
make_trampoline_internal(base0)
     object *base0;
{super_funcall_no_event(base0[0]->c.c_car);}

static
make_turbo_trampoline_internal(base0)
     object *base0;
{ object function=base0[0]->c.c_car;
  (*function->cc.cc_self)(function->cc.cc_turbo);
}

")

(defentry make-trampoline (object) (object make_trampoline))
)

#+IBCL
(progn ; From Rainy Day PCL.

(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))

(defconstant funcallable-instance-closure-size 15)

(defun allocate-funcallable-instance-1 ()
  (let ((fin (allocate-funcallable-instance-2))
    (env
      (make-list funcallable-instance-closure-size :initial-element nil)))
    (set-cclosure-env fin env)
    #+:turbo-closure (si:turbo-closure fin)
    (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
    (setf (car env) *funcallable-instance-marker*)
    fin))

(defun allocate-funcallable-instance-2 ()
  (let ((what-a-dumb-closure-variable ()))
    #'(lambda (&rest args)
    (declare (ignore args))
    (called-fin-without-function)
    (setq what-a-dumb-closure-variable
          (dummy-function what-a-dumb-closure-variable)))))

(defun funcallable-instance-p (x)
  (and (cclosurep x)
       (let ((env (cclosure-env x)))
     (when (listp env)
       (dotimes (i (1- funcallable-instance-closure-size)) (pop env))
       (eq (car env) *funcallable-instance-marker*)))))

(defun set-funcallable-instance-function (fin new-value)
  (cond ((not (funcallable-instance-p fin))
         (error "~S is not a funcallable-instance" fin))
        ((not (functionp new-value))
         (error "~S is not a function." new-value))
        ((cclosurep new-value)
         (let* ((fin-env (cclosure-env fin))
                (new-env (cclosure-env new-value))
                (new-env-size (length new-env))
                (fin-env-size (- funcallable-instance-closure-size
                                 (length funcallable-instance-data)
                 1)))
           (cond ((<= new-env-size fin-env-size)
          (do ((i 0 (+ i 1))
               (new-env-tail new-env (cdr new-env-tail))
               (fin-env-tail fin-env (cdr fin-env-tail)))
              ((= i fin-env-size))
            (setf (car fin-env-tail)
              (if (< i new-env-size)
                  (car new-env-tail)
                  nil)))
          (set-cclosure-self fin (cclosure-self new-value))
          (set-cclosure-data fin (cclosure-data new-value))
          (set-cclosure-start fin (cclosure-start new-value))
          (set-cclosure-size fin (cclosure-size new-value)))
                 (t
                  (set-funcallable-instance-function
                    fin
                    (make-trampoline new-value))))))
    ((typep new-value 'compiled-function)
     ;; Write NILs into the part of the cclosure environment that is
     ;; not being used to store the funcallable-instance-data.  Then
     ;; copy over the parts of the compiled function that need to be
     ;; copied over.
     (let ((env (cclosure-env fin)))
       (dotimes (i (- funcallable-instance-closure-size
              (length funcallable-instance-data)
              1))
         (setf (car env) nil)
         (pop env)))
     (set-cclosure-self fin (cfun-self new-value))
     (set-cclosure-data fin (cfun-data new-value))
     (set-cclosure-start fin (cfun-start new-value))
     (set-cclosure-size fin (cfun-size new-value)))
        (t
         (set-funcallable-instance-function fin
                                            (make-trampoline new-value))))
  fin)


(defun make-trampoline (function)
  #'(lambda (&rest args)
      (apply function args)))

;; this replaces funcallable-instance-data-1, set-funcallable-instance-data-1
;; and the defsetf
(defmacro funcallable-instance-data-1 (fin data &environment env)
  ;; The compiler won't expand macros before deciding on optimizations,
  ;; so we must do it here.
  (let* ((pos-form (macroexpand `(funcallable-instance-data-position ,data)
                env))
     (index-form (if (constantp pos-form)
             (- funcallable-instance-closure-size
                (eval pos-form)
                2)
             `(- funcallable-instance-closure-size
                 (funcallable-instance-data-position ,data)
                 2))))
    #+:turbo-closure `(car (tc-cclosure-env-nthcdr ,index-form ,fin))
    #-:turbo-closure `(nth ,index-form (cclosure-env ,fin))))

)


;;;
;;; In H.P. Common Lisp
;;; This code was originally written by:
;;;    [e-mail]     (James Kempf)
;;;    [e-mail]    (Roy D'Souza)
;;;
#+HP-HPLabs
(progn

(defmacro fin-closure-size ()`(prim::@* 6 prim::bytes-per-word))

(defmacro fin-set-mem-hword ()
  `(prim::@set-mem-hword
     (prim::@+ fin (prim::@<< 2 1))
     (prim::@+ (prim::@<< 2 8)
           (prim::@fundef-info-parms (prim::@fundef-info fundef)))))

(defun allocate-funcallable-instance-1()
  (let* ((fundef
       #'(lambda (&rest ignore)
           (declare (ignore ignore))
           (called-fin-without-function)))
     (static-link (vector 'lisp::*undefined* NIL NIL NIL NIL NIL))
     (fin (prim::@make-fundef (fin-closure-size))))
    (fin-set-mem-hword)
    (prim::@set-svref fin 2 fundef)
    (prim::@set-svref fin 3 static-link)
    (prim::@set-svref fin 4 0)
    (impl::PlantclosureHook fin)
    fin))

(defmacro funcallable-instance-p (possible-fin)
  `(= (fin-closure-size) (prim::@header-inf ,possible-fin)))

(defun set-funcallable-instance-function (fin new-function)
  (cond ((not (funcallable-instance-p fin))
     (error "~S is not a funcallable instance.~%" fin))
    ((not (functionp new-function))
     (error "~S is not a function." new-function))
    (T
     (prim::@set-svref fin 2 new-function))))

(defmacro funcallable-instance-data-1 (fin data)
  `(prim::@svref (prim::@closure-static-link ,fin)
         (+ 2 (funcallable-instance-data-position ,data))))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(prim::@set-svref (prim::@closure-static-link ,fin)
             (+ (funcallable-instance-data-position ,data) 2)
             ,new-value))

(defun funcallable-instance-name (fin)
  (prim::@svref (prim::@closure-static-link fin) 1))

(defsetf funcallable-instance-name set-funcallable-instance-name)

(defun set-funcallable-instance-name (fin new-name)
  (prim::@set-svref (prim::@closure-static-link fin) 1 new-name))

);end #+HP



;;;
;;; In Golden Common Lisp.
;;; This code was originally written by:
;;;    [e-mail]     (Dan Jacobs)
;;;
;;; GCLISP supports named structures that are specially marked as funcallable.
;;; This allows FUNCALLABLE-INSTANCE-P to be a normal structure predicate,
;;; and allows ALLOCATE-FUNCALLABLE-INSTANCE-1 to be a normal boa-constructor.
;;;
#+GCLISP
(progn

(defstruct (%funcallable-instance
         (:predicate funcallable-instance-p)
         (:copier nil)
         (:constructor allocate-funcallable-instance-1 ())
         (:print-function
          (lambda (struct stream depth)
        (declare (ignore depth))
        (print-object struct stream))))
  (function    #'(lambda (ignore-this &rest ignore-these-too)
            (declare (ignore ignore-this ignore-these-too))
            (called-fin-without-function))
        :type function)
  (%hidden%    'gclisp::funcallable :read-only t)
  (data        (vector nil nil) :type simple-vector :read-only t))

(proclaim '(inline set-funcallable-instance-function))
(defun set-funcallable-instance-function (fin new-value)
  (setf (%funcallable-instance-function fin) new-value))

(defmacro funcallable-instance-data-1 (fin data)
  `(svref (%funcallable-instance-data ,fin)
      (funcallable-instance-data-position ,data)))

)


;;;
;;; Explorer Common Lisp
;;; This code was originally written by:
;;;    [e-mail]
;;;
#+ti
(progn

#+(or :ti-release-3 (and :ti-release-2 elroy))
(defmacro lexical-closure-environment (l)
  `(cdr (si:%make-pointer si:dtp-list
              (cdr (si:%make-pointer si:dtp-list ,l)))))

#-(or :ti-release-3 elroy)
(defmacro lexical-closure-environment (l)
  `(caar (si:%make-pointer si:dtp-list
               (cdr (si:%make-pointer si:dtp-list ,l)))))

(defmacro lexical-closure-function (l)
  `(car (si:%make-pointer si:dtp-list ,l)))


(defvar *funcallable-instance-marker* (list "Funcallable Instance Marker"))

(defconstant funcallable-instance-closure-size 15) ; NOTE: In order to avoid
                           ; hassles with the reader,
(defmacro allocate-funcallable-instance-2 ()       ; these two 15's are the
  (let ((l ()))                       ; same.  Be sure to keep
    (dotimes (i 15)                   ; them consistent.
      (push (list (gensym) nil) l))
    `(let ,l
       #'(lambda (ignore &rest ignore-them-too)
       (declare (ignore ignore ignore-them-too))
       (called-fin-without-function)
       (values . ,(mapcar #'car l))))))

(defun allocate-funcallable-instance-1 ()
  (let* ((new-fin (allocate-funcallable-instance-2)))
    (setf (car (nthcdr (1- funcallable-instance-closure-size)
               (lexical-closure-environment new-fin)))
      *funcallable-instance-marker*)
    new-fin))

(eval-when (eval) (compile 'allocate-funcallable-instance-1))

(proclaim '(inline funcallable-instance-p))
(defun funcallable-instance-p (x)
  (and (typep x #+:ti-release-2 'closure
            #+:ti-release-3 'si:lexical-closure)
       (let ((env (lexical-closure-environment x)))
     (eq (nth (1- funcallable-instance-closure-size) env)
         *funcallable-instance-marker*))))

(defun set-funcallable-instance-function (fin new-value)
  (cond ((not (funcallable-instance-p fin))
     (error "~S is not a funcallable-instance"))
    ((not (functionp new-value))
     (error "~S is not a function."))
    ((typep new-value 'si:lexical-closure)
     (let* ((fin-env (lexical-closure-environment fin))
        (new-env (lexical-closure-environment new-value))
        (new-env-size (length new-env))
        (fin-env-size (- funcallable-instance-closure-size
                 (length funcallable-instance-data)
                 1)))
       (cond ((<= new-env-size fin-env-size)
          (do ((i 0 (+ i 1))
               (new-env-tail new-env (cdr new-env-tail))
               (fin-env-tail fin-env (cdr fin-env-tail)))
              ((= i fin-env-size))
            (setf (car fin-env-tail)
              (if (< i new-env-size)
                  (car new-env-tail)
                  nil)))
          (setf (lexical-closure-function fin)
            (lexical-closure-function new-value)))
         (t
          (set-funcallable-instance-function
            fin
            (make-trampoline new-value))))))
    (t
     (set-funcallable-instance-function fin
                        (make-trampoline new-value)))))

(defun make-trampoline (function)
  (let ((tmp))
    #'(lambda (&rest args) tmp
    (apply function args))))

(eval-when (eval) (compile 'make-trampoline))

(defmacro funcallable-instance-data-1 (fin data)
  `(let ((env (lexical-closure-environment ,fin)))
     (nth (- funcallable-instance-closure-size
         (funcallable-instance-data-position ,data)
         2)
      env)))


(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(let ((env (lexical-closure-environment ,fin)))
     (setf (car (nthcdr (- funcallable-instance-closure-size
               (funcallable-instance-data-position ,data)
               2)
            env))
       ,new-value)))

);end of code for TI


;;; Implemented by Bein@pyramid -- Tue Aug 25 19:05:17 1987
;;;
;;; A FIN is a distinct type of object which FUNCALL,EVAL, and APPLY
;;; recognize as functions. Both Compiled-Function-P and functionp
;;; recognize FINs as first class functions.
;;;
;;; This does not work with PyrLisp versions earlier than 1.1..

#+pyramid
(progn

(defun make-trampoline (function)
    #'(lambda (&rest args) (apply function args)))

(defun un-initialized-fin (&rest trash)
    (declare (ignore trash))
    (called-fin-without-function))

(eval-when (eval)
    (compile 'make-trampoline)
    (compile 'un-initialized-fin))

(defun allocate-funcallable-instance-1 ()
    (let ((fin (system::alloc-funcallable-instance)))
      (system::set-fin-function fin #'un-initialized-fin)
      fin))

(defun funcallable-instance-p (object)
  (typep object 'lisp::funcallable-instance))

(clc::deftransform funcallable-instance-p trans-fin-p (object)
    `(typep ,object 'lisp::funcallable-instance))

(defun set-funcallable-instance-function (fin new-value)
    (or (funcallable-instance-p fin)
    (error "~S is not a funcallable-instance." fin))
    (cond ((not (functionp new-value))
       (error "~S is not a function." new-value))
      ((not (lisp::compiled-function-p new-value))
       (set-funcallable-instance-function fin
                          (make-trampoline new-value)))
      (t
       (system::set-fin-function fin new-value))))

(defun funcallable-instance-data-1 (fin data-name)
  (system::get-fin-data fin
            (funcallable-instance-data-position data-name)))

(defun set-funcallable-instance-data-1 (fin data-name value)
  (system::set-fin-data fin
            (funcallable-instance-data-position data-name)
            value))

(defsetf funcallable-instance-data-1 set-funcallable-instance-data-1)

); End of #+pyramid


;;;
;;; For Coral Lisp
;;;
#+:coral
(progn

(defconstant ccl::$v_istruct 22)
(defvar ccl::initial-fin-slots (make-list (length funcallable-instance-data)))
(defconstant ccl::fin-function 1)
(defconstant ccl::fin-data (+ ccl::FIN-function 1))

(defun allocate-funcallable-instance-1 ()
  (apply #'ccl::%gvector
         ccl::$v_istruct
         'ccl::funcallable-instance
         #'(lambda (&rest ignore)
             (declare (ignore ignore))
         (called-fin-without-function))
         ccl::initial-fin-slots))

#+:ccl-1.3
(eval-when (eval compile load)

;;; Make uvector-based objects (like funcallable instances) print better.
(defun print-uvector-object (obj stream &optional print-level)
  (declare (ignore print-level))
  (print-object obj stream))

;;; Inform the print system about funcallable instance uvectors.
(pushnew (cons 'ccl::funcallable-instance #'print-uvector-object)
     ccl:*write-uvector-alist*
     :test #'equal)

)

(defun funcallable-instance-p (x)
  (and (eq (ccl::%type-of x) 'ccl::internal-structure)
       (eq (ccl::%uvref x 0) 'ccl::funcallable-instance)))

(defun set-funcallable-instance-function (fin new-value)
  (unless (funcallable-instance-p fin)
    (error "~S is not a funcallable-instance." fin))
  (unless (functionp new-value)
    (error "~S is not a function." new-value))
  (ccl::%uvset fin ccl::FIN-function new-value))

(defmacro funcallable-instance-data-1 (fin data-name)
  `(ccl::%uvref ,fin
                (+ (funcallable-instance-data-position ,data-name)
           ccl::FIN-data)))

(defsetf funcallable-instance-data-1 (fin data) (new-value)
  `(ccl::%uvset ,fin
                (+ (funcallable-instance-data-position ,data) ccl::FIN-data)
                ,new-value))

); End of #+:coral



;;;; Slightly Higher-Level stuff built on the implementation-dependent stuff.
;;;
;;;

(defmacro fsc-instance-p (fin)
  `(funcallable-instance-p ,fin))

(defmacro fsc-instance-class (fin)
  `(wrapper-class (funcallable-instance-data-1 ,fin 'wrapper)))

(defmacro fsc-instance-wrapper (fin)
  `(funcallable-instance-data-1 ,fin 'wrapper))

(defmacro fsc-instance-slots (fin)
  `(funcallable-instance-data-1 ,fin 'slots))